home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-zelk / zelk.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-13  |  22.2 KB  |  987 lines
  1. /* zelk.c zilla 3sep91 - assorted elk extensions, also master init.
  2.  *
  3.     Portions of this file are Copyright (C) 1991 John Lewis,
  4.     adapted from Elk2.0 by Oliver Laumann.
  5.  
  6.     This file is free software; you can redistribute it and/or modify
  7.     it under the terms of the GNU General Public License as published by
  8.     the Free Software Foundation.
  9.  
  10.     This program is distributed in the hope that it will be useful,
  11.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13.     GNU General Public License for more details.
  14.  
  15.     You should have received a copy of the GNU General Public License
  16.     along with this program; if not, write to the Free Software
  17.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
  20.  ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
  21.  ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
  22.  ****AFTER A GC.
  23.  *
  24.  * modified
  25.  * 11nov        cleanup
  26.  * 28may        os-peekchar.  see comment re why this vs. peek-char.
  27.  * 30apr        os-architecture
  28.  * 23apr        Get_Flonum
  29.  * 12apr        fmod
  30.  * 3mar         prelink elk lib/chdir,unix
  31.  * 2mar         (alarm-set), alarm-handler!
  32.  * 1mar         add cshf=csh -f
  33.  */
  34.  
  35. #include <theusual.h>
  36. #include <constants.h>
  37. #include <scheme.h>
  38. #include <zelk.h>
  39. #include <assert.h>
  40.  
  41.  
  42. /*%%%%%%%%%%%%%%%% declarations used by pre-linked functions %%%%*/
  43.  
  44. #if Eunix 
  45.  
  46. # if Eansiincludes
  47. #   include <unistd.h>
  48. # else
  49.     extern char *getenv();
  50.     extern int4 sleep();
  51.     extern int chmod();
  52. # endif /*!Eansiincludes*/
  53.  
  54.   extern int getpid();
  55. # if Ebsd
  56.     extern int getppid();
  57. # endif
  58.   extern int unlink(),rename();
  59.   extern pclose( /*FILE *stream*/ ); 
  60.  
  61. # if Esparc  /* SGI declares these in stdio.h */
  62.    extern fclose(),fseek(); 
  63.    extern int4 fread(),fwrite();
  64. # endif
  65.  
  66. # if Esgi  /* not declared anywhere in /usr/include on sgi */
  67.    extern int chmod();
  68. #endif
  69.  
  70. #endif /*Eunix*/
  71.  
  72.  
  73. #ifdef ZILLAONLY
  74. # include <libzs.h>
  75. # if Esparc
  76.   extern void malloc_verify();
  77. # endif
  78. #endif
  79.  
  80.  
  81. /*%%%%%%%%%%%%%%%% 1. elk internal addtions %%%%%%%%%%%%%%%%*/
  82.  
  83. Dfloat Get_Flonum(F)
  84.   Object F;
  85. {
  86.   if (TYPE(F) != T_Flonum) Primitive_Error("bad type-expected float");
  87.   return FLONUM(F)->val;
  88. }
  89.  
  90. /* convert an elk string to a statically allocated c string
  91.  * !! also see lib/util/string.h !!
  92.  */
  93. char *Get_Cstring(str)
  94.   Object str;
  95. {
  96.   int slen;
  97.  
  98.   slen = STRING(str)->size;
  99.   if ((TYPE(str) != T_String) || (slen >= Ctmpbuflen))
  100.     Panic("Get_Cstring");
  101.   Zbcopy(STRING(str)->data,Ctmpbuf,slen);
  102.   Ctmpbuf[slen] = (char)0;
  103.  
  104.   return(Ctmpbuf);
  105. } /*Get_Cstring*/
  106.  
  107.  
  108. /* scheme in general does not allow control over whether things are
  109.  * int or float.  the closest equivalent is exact->inexact, which
  110.  * elk does not have.  fully maintaining the exact/inexact distinction
  111.  * would require another bit for all numbers, which would degrade
  112.  * some implementations with immediate integers (such as elk).
  113.  * We need control of int/float, for example, to allocate
  114.  * the right type of arrays in vdistribute.
  115.  * Also,
  116.  * (/ 3 4)=>0.75 in both elk and xscheme; what about the scheme standard
  117.  * if rationals are not implemented??
  118.  * I don't want to rely on this feature of elk, so, adding a (float) call.
  119.  */
  120.  
  121. Object P_float(I)
  122.   Object I;
  123. {
  124.   int i;
  125.   if (TYPE(I) == T_Flonum) return I;
  126.   i = Get_Integer(I);
  127.   return Make_Reduced_Flonum((double)i);
  128. }
  129.  
  130.  
  131. /* the elk builtin peek-char actually hangs - it reads one character,
  132.  * and then puts it back in an elk (not stdio) char buffer.
  133.  * It works with string ports, and is suitable for parsing,
  134.  * but is not suitable for real-time user interaction e.g.
  135.  * quit this loop when the user types something.
  136.  * Ioctl test for input only works with terminal, not other streams?
  137.  */
  138.  
  139. #ifdef NO  /* this would also need to ungetc the character!! */
  140. static Object P_peektty () {
  141.     register int c;
  142.     
  143.     c = Zio_getcif();
  144.  
  145.     if (c == 4) return False;
  146.     if (c == -1) return False;
  147.  
  148.     return Make_Char(c);
  149. }
  150. #endif /*NO*/
  151.  
  152. /*%%%%%%%%%%%%%%%% 2. os routines %%%%%%%%%%%%%%%%*/
  153.  
  154. /* filename matching */
  155. static Object P_glob(pattern)
  156.   Object pattern;
  157. {
  158. # define maxmatch 2048
  159.   char *match[maxmatch];
  160.   char cpattern[CMAXPATH];
  161.   int i,nmatch;
  162.  
  163.   Error_Tag = "os-glob";
  164.   Check_Type(pattern,T_String);
  165.   str_cpy(cpattern,Get_Cstring(pattern));
  166.   Ztrace(("glob %s\n",cpattern));
  167.  
  168.   i = nmatch = Zglob(cpattern, match, maxmatch);
  169.   Ztrace(("glob %s => %d matches\n",cpattern,nmatch));
  170.  
  171.   {
  172.     Object list,tail,cell;
  173.     GC_Node2;
  174.  
  175.     GC_Link2(list,tail);
  176.     for (list = tail = Null; --i >= 0; tail = cell) {
  177.         Ztrace(("adding %d:%s\n",i,match[i]));
  178.     cell = Cons( Make_String(match[i],str_len(match[i])), Null );
  179.     if (Nullp (list))
  180.         list = cell;
  181.     else
  182.         P_Setcdr (tail, cell);
  183.     }
  184.     GC_Unlink;
  185.  
  186.     /* Zglob returns pointers to malloced strings */
  187.     for( i=0; i < nmatch; i++ ) free(match[i]);
  188.  
  189.     return list;
  190.   }
  191. # undef maxmatch 
  192. } /*glob*/
  193.  
  194.  
  195. #if Eunix
  196.  
  197. #if ELKV2 /*%%%% elk version 2 %%%%*/
  198. #include <cstring.h>
  199.  
  200. /* copied from elk/lib/unix.c; _csh needs this;
  201.    copy it rather than altering the source to make it global.
  202.  */
  203. static Open_Max () {
  204. #ifdef OPEN_MAX              /* POSIX */
  205.     return OPEN_MAX;
  206. #else
  207. #ifdef GETDTABLESIZE
  208.     return getdtablesize();  /* Return value may change during runtime */
  209. #else
  210. #ifdef SYSCONF
  211.     static r;
  212.     if (r == 0) {
  213.     if ((r = sysconf (_SC_OPEN_MAX)) == -1)
  214.         r = 256;
  215.     }
  216.     return r;
  217. #else
  218. #ifdef NOFILE
  219.     return NOFILE;
  220. #else
  221.     return 256;
  222. #endif
  223. #endif
  224. #endif
  225. #endif
  226. } /*Open_Max*/
  227.  
  228.  
  229. /* from lib/unix.c, only run csh rather than sh */
  230. static Object _csh (cmd,startup) 
  231.   Object cmd;
  232.   bool startup;         /* true to read startup (.cshrc) */
  233. {
  234.     register char *s;
  235.     register i, n, pid;
  236.     int status;
  237.     Declare_C_Strings;
  238.  
  239.     Make_C_String (cmd, s);
  240. #ifdef VFORK
  241.     switch (pid = vfork ()) {
  242. #else
  243.     switch (pid = fork ()) {
  244. #endif
  245.     case -1:
  246.     Saved_Errno = errno;
  247.     Primitive_Error ("cannot fork: ~E");
  248.     case 0:
  249.     n = Open_Max ();
  250.     for (i = 3; i < n; i++)
  251.         (void)close (i);
  252.  
  253.         if (startup)
  254.           execl ("/bin/csh", "csh", "-c", s, (char *)0);
  255.         else
  256.           execl ("/bin/csh", "csh", "-f", "-c", s, (char *)0);
  257.  
  258.         perror("elk (csh) execl failed");
  259.     _exit (127);
  260.     default:
  261.     Disable_Interrupts;
  262.     while ((i = wait (&status)) != pid && i != -1)
  263.         ;
  264.     Enable_Interrupts;
  265.     }
  266.     Dispose_C_Strings;
  267.     if (i == -1)
  268.     return False;
  269.     if (n = (status & 0377))
  270.     return Cons (Make_Fixnum (n), Null);
  271.     return Make_Fixnum ((status >> 8) & 0377);
  272. } /*_csh*/
  273.  
  274.  
  275. #else /*%%%% version 1* %%%%*/
  276. #include <string.h>
  277.  
  278. /* from lib/system, only run csh rather than sh */
  279. static Object _csh (cmd,startup) 
  280.   Object cmd;
  281.   bool startup;         /* true to read startup (.cshrc) */
  282. {
  283.     register char *s;
  284.     register i, n, pid;
  285.     int status;
  286.     Declare_C_Strings;
  287.  
  288.     Make_C_String (cmd, s);
  289. #ifdef VFORK
  290.     switch (pid = vfork ()) {
  291. #else
  292.     switch (pid = fork ()) {
  293. #endif
  294.     case -1:
  295.     Saved_Errno = errno;
  296.     Primitive_Error ("cannot fork: ~E");
  297.     case 0:
  298. #ifdef MAX_OFILES
  299.     n = MAX_OFILES;
  300. #else
  301. #ifdef SYSCONF
  302.     n = sysconf (_SC_OPEN_MAX);
  303. #else
  304.     n = getdtablesize ();
  305. #endif
  306. #endif
  307.     for (i = 3; i < n; i++)
  308.         (void)close (i);
  309.         if (startup)
  310.           execl ("/bin/csh", "csh", "-c", s, (char *)0);
  311.         else
  312.           execl ("/bin/csh", "csh", "-f", "-c", s, (char *)0);
  313.  
  314.         perror("elk (csh) execl failed");
  315.     _exit (127);
  316.  
  317.     default:
  318.     Disable_Interrupts;
  319.     while ((i = wait (&status)) != pid && i != -1)
  320.         ;
  321.     Enable_Interrupts;
  322.     }
  323.     Dispose_C_Strings;
  324.     if (i == -1)
  325.     return False;
  326.     if (n = (status & 0377))
  327.     return Cons (Make_Fixnum (n), Null);
  328.     return Make_Fixnum ((status >> 8) & 0377);
  329. } /*_csh*/
  330.  
  331. #endif /*%%%% version 1* %%%%*/
  332.  
  333.  
  334. static Object P_csh (cmd)   Object cmd; 
  335. {
  336.   return _csh(cmd,TRUE);
  337. }
  338.  
  339. static Object P_cshf (cmd)   Object cmd; 
  340. {
  341.   return _csh(cmd,FALSE);
  342. }
  343.  
  344. #endif /*unix*/
  345.  
  346.  
  347. #if Eunix
  348. static void
  349. osmkdir(path,mode)
  350.   char *path;
  351.   int mode;
  352. {
  353.   int rc;
  354.   extern int errno;
  355.   Error_Tag = "os-mkdir";
  356.  
  357.   errno = 0;
  358.   rc = mkdir(path,mode);
  359.   if (rc < 0) {
  360.     perror("os-mkdir");
  361.     Primitive_Error("failed");
  362.   }
  363. }
  364. #endif /*unix*/
  365.  
  366.  
  367. #ifdef OBSOLETE
  368. /* getenv is now linked as a foreign function */
  369. static Object P_Getenv (e) Object e; {
  370.     register char *s;
  371.     Object ret;
  372.     Declare_C_Strings;
  373.  
  374.     Make_C_String (e, s);
  375.     ret = (s = getenv (s)) ? Make_String (s, strlen (s)) : False;
  376.     Dispose_C_Strings;
  377.     return ret;
  378. } /*getenv*/
  379. #endif
  380.  
  381.  
  382. /* os-exec(string). returns a pid which can be waited for with
  383.  * os-waitpid.
  384.  * Based on elk unix.c P_system() call.
  385.  */
  386. #if Eunix
  387.  
  388. #define DEF_EXEC   Define_Primitive (P_Exec, "os-exec",  1,1,EVAL);
  389.  
  390. #if ELKV2       /*%%%% elk version 2 %%%%*/
  391.  
  392. static Object P_Exec (cmd) Object cmd; {
  393.     register char *s;
  394.     register i, n, pid;
  395.     Declare_C_Strings;
  396.     Error_Tag = "os-exec";
  397.  
  398.     Make_C_String (cmd, s);
  399. #ifdef VFORK
  400.     switch (pid = vfork ()) {
  401. #else
  402.     switch (pid = fork ()) {
  403. #endif
  404.     case -1:
  405.     Saved_Errno = errno;
  406.     Primitive_Error ("cannot fork: ~E");
  407.     case 0:
  408.     n = Open_Max ();
  409.     for (i = 3; i < n; i++)
  410.         (void)close (i);
  411.  
  412.     execl ("/bin/sh", "sh", "-c", s, (char *)0);
  413.         perror("os-exec");
  414.     /* Primitive_Error ("cannot exec"); */
  415.     _exit (127);
  416.     default:
  417.         break;
  418.     }
  419.     Dispose_C_Strings;
  420.     return Make_Fixnum(pid);
  421. } /*P_exec*/
  422.  
  423.  
  424. #else   /*%%%% elk version 1* %%%%*/
  425.  
  426. static Object P_Exec (cmd) Object cmd; {
  427.     register char *s;
  428.     register i, n, pid;
  429.     Declare_C_Strings;
  430.     Error_Tag = "os-exec";
  431.  
  432.     Make_C_String (cmd, s);
  433. #ifdef VFORK
  434.     switch (pid = vfork ()) {
  435. #else
  436.     switch (pid = fork ()) {
  437. #endif
  438.     case -1:
  439.     Saved_Errno = errno;
  440.     Primitive_Error ("cannot fork: ~E");
  441.     case 0:
  442. #ifdef MAX_OFILES
  443.     n = MAX_OFILES;
  444. #else
  445. #ifdef SYSCONF
  446.     n = sysconf (_SC_OPEN_MAX);
  447. #else
  448.     n = getdtablesize ();
  449. #endif
  450. #endif
  451.     for (i = 3; i < n; i++)
  452.         (void)close (i);
  453.     execl ("/bin/sh", "sh", "-c", s, (char *)0);
  454.         perror("os-exec");
  455.     /* Primitive_Error ("cannot exec"); */
  456.     _exit (127);
  457.     default:
  458.         break;
  459.     } /*switch*/
  460.  
  461.     Dispose_C_Strings;
  462.     return Make_Fixnum(pid);
  463. } /*P_exec*/
  464.  
  465. #endif  /*%%%% elk version 1 %%%%*/
  466.  
  467. #define DEF_WAITPID     Define_Primitive (P_Waitpid, "os-waitpid",1,1,EVAL);
  468.  
  469. static Object P_Waitpid(Pid)
  470.   Object Pid;
  471. {
  472.   int i,n,pid;
  473.   int status;
  474.   Error_Tag = "os-waitpid";
  475.  
  476.   pid = Get_Integer(Pid);
  477.  
  478.   Disable_Interrupts;
  479.   while ((i = wait (&status)) != pid && i != -1)
  480.     ;
  481.   Enable_Interrupts;
  482.   if (i == -1)
  483.     return False;
  484.   if (n = (status & 0377))
  485.     return Cons (Make_Fixnum (n), Null);        /* signal ? */
  486.   return Make_Fixnum ((status >> 8) & 0377);    /* status */
  487. } /*P_waitpid*/
  488.  
  489. #endif /*Unix*/
  490.  
  491.  
  492. #if Eunix
  493. /*%%%%%%%%%%%%%%%% setenv,unsetenv %%%%%%%%%%%%%%%%
  494.  * unix "environment" is an array of "NAME=VALUE" strings
  495.  * which is passed between processes in the global variable 'char **environ'.
  496.  * to allow additions to the environment, we copy the original environment
  497.  * list (as passed to us e.g. from csh) into a new array known to be
  498.  * malloced by us and to have some free slots, then set 'environ' to this.
  499.  * 
  500.  * to add something, search for the NAME= in the existing array,
  501.  * free and replace if found, if not, add at end.
  502.  *
  503.  * how to unsetenv something?
  504.  * setting entry to (char *)0 ends the list and makes following entries
  505.  * inaccessible.  Instead, copy the whole environment to a second
  506.  * array, omitting the unsetenv item, and then set environ to the
  507.  * new array (after freeing the old array).  Requires two static arrays.
  508.  */
  509.  
  510. extern char **environ;
  511.  
  512. #define ENVN 1024
  513. static char *Env1[ENVN] = {""};
  514. static char *Env2[ENVN] = {""};
  515.  
  516. /* helper: copy original environment to one which we have malloced,
  517.  * so we can free entries as needed by unsetenv 
  518.  */
  519.  
  520. static void
  521. copyenv()
  522. {
  523.   register int i;
  524.   register char **ep;
  525.   Error_Tag = "setenv";
  526.   Ztrace(("setenv copying original environ\n"));
  527.  
  528.   for( i = 0, ep = environ; *ep; ep++, i++ ) {
  529.     if (i == ENVN) Primitive_Error("too many entries");
  530.     Env1[i] = Zsalloc(*ep);
  531.   }
  532.   Env1[i] = (char *)0;
  533.   environ = Env1;
  534. } /*copyenv*/
  535.  
  536.  
  537. /* setenv(name,value) - APPEARS to be working */
  538. static void
  539. elksetenv(name,value)
  540.   char *name,*value;
  541. {
  542.     char *splice;
  543.     register char **ep;
  544.     Error_Tag = "setenv";
  545.     Ztrace(("setenv %s %s\n",name,value));
  546.  
  547.     if ((name == (char *)0) || (value == (char *)0))
  548.       Primitive_Error("need both name, value args");
  549.  
  550.     /* if just starting, copy original environment to one which we have
  551.      * malloced ourselves
  552.      */
  553.     if ((environ != Env1) && (environ != Env2)) copyenv();
  554.  
  555.     /* create "NAME=VALUE" string 'splice' */
  556.     {
  557.     int len;
  558.     len = strlen(name) + 1 + strlen(value);
  559.     splice = malloc((unsigned int)(len+1));
  560.     strcpy(splice,name); strcat(splice,"="); strcat(splice,value);
  561.     }
  562.  
  563.     /* search for existing NAME entry, replace if found */
  564.     for (ep = environ; *ep; ep++) {
  565.     register char *cp,*dp;
  566.     for (cp = name, dp = *ep; *cp && *cp == *dp; cp++, dp++)
  567.         continue;
  568.     if (*cp != 0 || *dp != '=')
  569.         continue;
  570.  
  571.     /* found it.  free and replace */
  572.     Ztrace(("setenv existing entry %s\n",*ep));
  573.         free(*ep);
  574.  
  575.         *ep = splice;
  576.  
  577.     return;
  578.     }
  579.  
  580.     /* add new entry at end of array */
  581.     Ztrace(("setenv adding entry at end\n"));
  582.     assert( *ep == (char *)0 );
  583.     if ((ep - environ) >= (ENVN-1)) Primitive_Error("environment is full");
  584.     *ep++ = splice;
  585.     *ep++ = (char *)0;
  586. } /*setenv*/
  587.  
  588.  
  589.  
  590. /* APPEARS to work */
  591. static void
  592. elkunsetenv(name)
  593.   char *name;
  594. {
  595.   register char **ep,**ep2;
  596.   bool found = FALSE;
  597.   Error_Tag = "unsetenv";
  598.   Ztrace(("unsetenv %s\n",name));
  599.  
  600.   if ((environ != Env1) && (environ != Env2))  copyenv();
  601.  
  602.   ep = environ;
  603.  
  604.   /* search for existing NAME entry, replace if found */
  605.   for (; *ep; ep++) {
  606.     register char *cp,*dp;
  607.     for (cp = name, dp = *ep; *cp && *cp == *dp; cp++, dp++) 
  608.       continue;
  609.     if (*cp != 0 || *dp != '=')
  610.       continue;
  611.  
  612.     /* found it.  free and zero */
  613.     Ztrace(("unsetenv found entry %s\n",*ep));
  614.     free(*ep);
  615.     *ep = (char *)1;    /* !! flag unset !! */
  616.     found = TRUE;
  617.  
  618.     break;
  619.   }
  620.  
  621.   if (!found) Primitive_Error("not found"); /* break before copying */
  622.  
  623.   if (environ == Env1) {
  624.     ep = Env1; ep2 = Env2;
  625.   }
  626.   else if (environ == Env2) {
  627.     ep = Env2; ep2 = Env1;
  628.   }
  629.   else Panic("unsetenv");
  630.  
  631.   environ = ep2;
  632.  
  633.   /* copy to another array */
  634.   for (; *ep; ep++) {
  635.     if (*ep != (char *)1) {
  636.       *ep2++ = Zsalloc(*ep);
  637.       free(*ep);
  638.       *ep = (char *)0;
  639.     }
  640.   }
  641.   *ep2 = (char *)0;
  642.  
  643. } /*unsetenv*/
  644.  
  645. #endif /*Eunix*/
  646.  
  647.  
  648.  
  649. #if Eunix       /*alarm*/
  650. #include <signal.h>
  651. #include <sys/time.h>
  652.  
  653. static Object V_Alarm_Handler;
  654.  
  655. /* this is the C signal handler; it calls the Elk handler if any */
  656. /* adapted from error.c:Intr_Handler */
  657. static void
  658. Alarm_Handler () {
  659.     Object fun;
  660.  
  661.     (void)signal (SIGALRM, SIG_IGN);
  662.  
  663.     Error_Tag = "alarm-handler";
  664.     Reset_IO (1);
  665.  
  666.     /* call alarm-handler if it is defined */
  667.     fun = Val (V_Alarm_Handler);
  668.     if (TYPE(fun) == T_Compound) {
  669.       (void)Funcall (fun, Null, 0);
  670.     }
  671.  
  672.     /* otherwise print this msg and call top-level */
  673.     Format (Curr_Output_Port, "~%\7Alarm Expired!~%", 19, 0, (Object *)0);
  674.     Reset ();
  675.     /*NOTREACHED*/
  676. } /*Alarm_Handler*/
  677.  
  678.  
  679. static Object
  680. P_Alarm_Set(Secs)
  681.   Object Secs;
  682. {
  683.   int which;
  684.   struct itimerval value;
  685.   int secs;
  686.   Error_Tag = "alarm-set";
  687.   secs = Get_Integer(Secs);
  688.  
  689.   if (secs == 0) {      /* disable alarm */
  690.     signal(SIGALRM,SIG_IGN);
  691.     return Null;
  692.   }
  693.  
  694.   value.it_value.tv_sec = secs;
  695.   value.it_value.tv_usec = 0;
  696.   value.it_interval.tv_sec = 0;
  697.   value.it_interval.tv_usec = 0;
  698.  
  699.   which = ITIMER_REAL;
  700.  
  701.   signal(SIGALRM,Alarm_Handler);
  702.   if (setitimer(which,&value,NULL) < 0) {
  703.     perror("alarm-set ");
  704.     Primitive_Error("setitimer problem");
  705.   }
  706.  
  707.   return Null;
  708. } /*alarm-set*/
  709. #endif /*Eunix alarm*/
  710.  
  711. static localinit_alarm() {
  712. #if Eunix
  713.   Define_Variable(&V_Alarm_Handler,"alarm-handler",Null);
  714.   Define_Primitive(P_Alarm_Set,"alarm-set",1,1,EVAL);
  715. #endif
  716. } /*init_alarm*/
  717.  
  718.  
  719.  
  720. /* call filesettimes given a human-readable time string */
  721. #if ZILLAONLY
  722. # include <rnd.h>
  723. static void
  724. os_filesettimestr(path,time)
  725.   char *path,*time;
  726. {
  727.   Ztime_t t;
  728.   t = Zparsetime(time);
  729.   t += (60*60*24)*rndf(); /* dither to prevent make stall */
  730.   Zfilesettimes(path,t,t);
  731. }
  732. #endif
  733.  
  734. #if Eunix
  735. static char *
  736. elkhostname()
  737. {
  738.   if (gethostname(Ctmpbuf,Ctmpbuflen) < 0)
  739.     perror("elk-gethostname");          /* going to stdout!! */
  740.   Ctmpbuf[Ctmpbuflen-1] = (char)0; /* make sure it is null-terminated */
  741.   return Ctmpbuf;
  742. }
  743. #endif
  744.  
  745.  
  746.  
  747. static char *elkarch()
  748. {
  749.  
  750. #if Emips
  751. # define gotarch
  752.   str_cpy(Ctmpbuf,"mips");
  753. #endif
  754.  
  755. #if Esparc
  756. # define gotarch
  757.   str_cpy(Ctmpbuf,"sparc");
  758. #endif
  759.  
  760. #ifdef mc68020
  761. # define gotarch
  762.   str_cpy(Ctmpbuf,"mc68020");
  763. #endif
  764.  
  765. #ifndef gotarch
  766.   :error elkarch()
  767. #endif
  768. # undef gotarch
  769.   return Ctmpbuf;
  770. } /*elkarch*/
  771.  
  772.  
  773.  
  774. #if Eunix
  775. extern char *getwd();
  776.  
  777. static char *elkgetwd()
  778. {
  779.   if (getwd(Ctmpbuf) == (char *)0)
  780.     perror("elk-getwd");          /* going to stdout!!? */
  781.   Ctmpbuf[Ctmpbuflen-1] = (char)0; /* make sure it is null-terminated */
  782.   return Ctmpbuf;
  783. }
  784. #endif /*unix*/
  785.  
  786.  
  787. #if Ebsd
  788.  
  789. /* kill all processes in the current (berkeley) 'process group',
  790.  * most probably, current process and all of its children.
  791.  */
  792. static void
  793. elkkillpg()
  794. {
  795.     kill(getpgrp(getpid()),9);
  796. }
  797.  
  798. /* kill all processes in the (berkeley) 'process group' of the parent.
  799.  * if parent is login csh, this is equivalent to kill all and logout
  800.  * (equivalent to kill 0 under sh, which is not effective under csh).
  801.  */
  802. static void
  803. elkkillppg()
  804. {
  805.     kill(getpgrp(getppid()),9);
  806. }
  807. #endif /*Ebsd*/
  808.  
  809.  
  810. #if Eunix
  811. /* logout *all* my processes on the current machine */
  812. static void
  813. elkkillall()
  814. {
  815.   kill(-1,2);   /* first kill nicely, with interrupt */
  816.   sleep(10);    /* wait for things to cleanup */
  817.   kill(-1,9);   /* kill meanly */
  818. }
  819. #endif
  820.  
  821.  
  822.  
  823. /*%%%%%%%%%%%%%%%% 3. standard pre-linked foreign functions %%%%*/
  824.  
  825. static struct fordef fortab[] = {
  826.  
  827. #if Eunix
  828.   {"os-delete-file", (vfunction *)unlink, "SRI"},
  829.   {"os-rename-file", (vfunction *)rename, "SSRI"},
  830.   {"os-chmod", (vfunction *)chmod, "SIRI"},
  831.   {"os-make-directory", (vfunction *)osmkdir, "SI"},
  832.   {"os-getenv", (vfunction *)getenv, "SRS"},
  833.   {"os-setenv", (vfunction *)elksetenv, "SS"},
  834.   {"os-unsetenv", (vfunction *)elkunsetenv, "S"},
  835.   {"os-sleep", (vfunction *)sleep, "I"},
  836.   {"os-hostname", (vfunction *)elkhostname, "RS"},
  837.   {"os-architecture", (vfunction *)elkarch, "RS"},
  838.   {"os-getwd", (vfunction *)elkgetwd, "RS"},    /* should be in libZ */
  839.  
  840.   {"os-popen",  (vfunction *)popen, "SSRP"}, /* ports can be returned */
  841.                                             /* now? */
  842.   {"os-pclose", (vfunction *)pclose, "P"},
  843.  
  844.   {"os-getpid", (vfunction *)getpid, "RI"},
  845.  
  846. # if Ebsd
  847.   {"os-getppid", (vfunction *)getppid, "RI"},
  848.   {"os-killpg", (vfunction *)elkkillpg, (char *)0},
  849.   {"os-killppg", (vfunction *)elkkillppg, (char *)0},
  850. # endif
  851.   {"os-killall", (vfunction *)elkkillall, (char *)0},
  852.  
  853.   {"os-filesettimes", (vfunction *)Zfilesettimes, "SII"},
  854. # if ZILLAONLY
  855.   {"os-filesettimestr", (vfunction *)os_filesettimestr, "SS"},
  856.   {"os-typeahead", (vfunction *)Zio_typeahead, "RI" },
  857. # if Esparc
  858.   /* on sparc, use /usr/lib/debug/malloc.o.
  859.    * this does some malloc checking by default.
  860.    */
  861.   {"imalloc-verify", (vfunction *)malloc_verify, (char *)0},
  862. # endif /*sparc*/
  863. # endif /*ZILLAONLY*/
  864.  
  865. #endif /*unix*/
  866.  
  867.   {"os-fopen", (vfunction *)fopen, "SSRP"},
  868.   {"os-fclose", (vfunction *)fclose, "P"},
  869.   {"os-fread", (vfunction *)fread, "AIIPRI"},
  870.   {"os-fwrite", (vfunction *)fwrite, "AIIPRI"},
  871.   {"os-fseek", (vfunction *)fseek, "PII"},
  872.   {"os-ftell", (vfunction *)ftell, "PRI"},
  873.  
  874.   {"os-filesize", (vfunction *)Zfilesize, "SRI"},
  875.   {"os-filedirp", (vfunction *)Zfiledirp, "SRB"},
  876.  
  877.   {"os-timestring", (vfunction *)Ztimestring, "IRS"},
  878.   {"os-curtime", (vfunction *)Zcurtime, "RI"},
  879. # if ZILLAONLY
  880.   {"os-parsetime", (vfunction *)Zparsetime, "SRI"},
  881. # endif
  882.   {"os-filemodtime", (vfunction *)Zfilemodtime, "SRI"},
  883.   {"os-fileacctime", (vfunction *)Zfileacctime, "SRI"},
  884.  
  885.   {"os-pathgetpath", (vfunction *)Zpathgetpath, "SRS"},
  886.   {"os-pathgetname", (vfunction *)Zpathgetname, "SRS"},
  887.   {"os-pathgetext", (vfunction *)Zpathgetext, "SRS"},
  888.   {"os-pathdelext", (vfunction *)Zpathdelext, "SRS"},
  889.  
  890.   {"os-uniqnam", (vfunction *)Zuniqnam, "SRS"},
  891.  
  892. /*  {"regex", (vfunction *)re_match, "SSRB"}, /+ pat,str */ 
  893.   
  894.   {"os-malloc", (vfunction *)malloc, "IRI"},
  895.   {"os-free", free, "I"},
  896.  
  897.   {"pow", (vfunction *)pow, "FFRF"},
  898.   {"atan2", (vfunction *)atan2, "FFRF"},
  899.   {"fmod", (vfunction *)fmod, "FFRF"},
  900.  
  901. #if ZILLAONLY
  902.   {"fft", (vfunction *)fft, "AAI"},
  903. #endif
  904.  
  905.   {(char *)0, (vfunction *)0, (char *)0}
  906. };
  907.  
  908.  
  909. #if ZILLAONLY
  910. /* preloaded packages. */
  911.   extern FORPKG0 pkg_RND1;
  912.   extern FORPKG0 pkg_RND2;
  913.   extern FORPKG0 pkg_RND3;
  914.   extern FORPKG0 pkg_VF;
  915.   extern FORPKG0 pkg_VFlib;
  916. /*  extern FORPKG0 pkg_GRAF; */
  917.  
  918. static void prelinkpkgs()
  919. {
  920.   Zforpkginit("pkg_VF",(PKG_type *)&pkg_VF);
  921.   Zforpkginit("pkg_VFlib",(PKG_type *)&pkg_VFlib);
  922.   Zforpkginit("pkg_RND1",(PKG_type *)&pkg_RND1);
  923.   Zforpkginit("pkg_RND2",(PKG_type *)&pkg_RND2);
  924.   Zforpkginit("pkg_RND3",(PKG_type *)&pkg_RND3);
  925. /*  Zforpkginit("pkg_GRAF",&pkg_GRAF); */
  926. } /*prelinkpkgs*/
  927. #endif /*ZILLAONLY*/
  928.  
  929.  
  930.  
  931. /* Master init for other extensions. 
  932.  * Farray must be inited before foreign because foreign depends T_farray.
  933.  */
  934. void Init_Zelk()
  935. {
  936.  
  937. /*Not done yet:
  938.   Define_Variable( &V_Flonum_Format, "flonum-format", Make_String("%g",2));
  939. */
  940.  
  941.   /* elk lib files which we decided to preload */
  942.   init_lib_chdir();
  943.   init_lib_unix();
  944.  
  945.   Init_farray();        /* link foreign array routines */
  946.   Init_foreign();       /* link the foreign function interface */
  947.   Init_peekpoke();      /* link foreign structure support */
  948.  
  949. # if ELKVECTOR
  950.   Init_vector();        /* link vector scheme */
  951. # endif
  952.  
  953. # if Esgi
  954.    Init_gl();           /* export SGI gl graphics routines */
  955. # endif
  956.  
  957. #if ZILLAONLY
  958.   Init_press();         /* temporary */
  959. # if Esparc
  960.    Init_posybl();       /* posybl/linda */
  961.    Init_GR();           /* graphics */
  962. # endif
  963.  
  964. # if Esgi
  965.    Init_GR();           /* graphics */
  966.    init_face();         /*tmp*/
  967. # endif
  968. #endif /*ZILLAONLY*/
  969.  
  970.   localinit_alarm();
  971.  
  972. /* various prelinked */
  973.   Define_Fortab(fortab);
  974.  
  975. #ifdef ZILLAONLY
  976.   prelinkpkgs();
  977. #endif
  978.  
  979.   Define_Primitive(P_glob,"os-glob",1,1,EVAL);
  980.   Define_Primitive(P_float,"float",1,1,EVAL);
  981.   Define_Primitive (P_csh, "csh",  1,1,EVAL);
  982.   Define_Primitive (P_cshf, "cshf",  1,1,EVAL);
  983.   DEF_EXEC
  984.   DEF_WAITPID
  985.  
  986. } /*Init_Zelk*/
  987.